home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0826.ZIP / EXEUTL.ARC / PACK.PAS < prev   
Pascal/Delphi Source File  |  1987-11-17  |  12KB  |  344 lines
  1. {
  2.  PACK reduces the size of EXE files by packing the EXE header table
  3.  into a smaller structure. It does so by using its own fixup relocator,
  4.  and building a table of fixups without redundant segment
  5.  information as occurs in the DOS standard format.
  6.  
  7.  PACK will also report how much space it could save by run-length
  8.  encoding repeated byte sequences. To see this effect, set the
  9.  constant ShowRLEeffect to True. PACK does not actually implement
  10.  this kind of packing at this time.
  11.  
  12.  PACK works in a manner similar to EXEPACK (from Microsoft) and
  13.  SPMAKER (from Realia).
  14.  
  15.  After compiling, just enter PACK to get directions for usage.
  16.  
  17.  Version 1.0.
  18.  Written 11/87, Kim Kokkonen, TurboPower Software.
  19.  Compuserve 72457,2131.
  20.  Released to the public domain.
  21. }
  22. {$S-,I-,R-}
  23.  
  24. program Pack;
  25.   {-Packs EXE file header structure}
  26.  
  27.   function StUpcase(S : string) : string;
  28.     {-Return uppercase of string}
  29.   var
  30.     I : integer;
  31.   begin
  32.     for I := 1 to length(S) do
  33.       S[I] := upcase(S[I]);
  34.     StUpcase := S;
  35.   end;
  36.  
  37.   function HasExtension(Name : string; var DotPos : Word) : Boolean;
  38.     {-Return whether and position of extension separator dot in a pathname}
  39.   var
  40.     I : Word;
  41.   begin
  42.     DotPos := 0;
  43.     for I := Length(Name) downto 1 do
  44.       if (Name[I] = '.') and (DotPos = 0) then
  45.         DotPos := I;
  46.     HasExtension := (DotPos > 0) and (Pos('\', Copy(Name, Succ(DotPos), 64)) = 0);
  47.   end;
  48.  
  49.   function ForceExtension(Name, Ext : string) : string;
  50.     {-Return a pathname with the specified extension attached}
  51.   var
  52.     DotPos : Word;
  53.   begin
  54.     if HasExtension(Name, DotPos) then
  55.       ForceExtension := Copy(Name, 1, DotPos)+Ext
  56.     else
  57.       ForceExtension := Name+'.'+Ext;
  58.   end;
  59.  
  60.   procedure Error(Msg : string);
  61.     {-Write error message and halt}
  62.   begin
  63.     if Msg <> '' then
  64.       WriteLn(^M^J, Msg);
  65.     Halt(1);
  66.   end;
  67.  
  68.   function BlkRead(var F : file; var Buffer; Size : Word) : Boolean;
  69.     {-Convenient shell around BlockRead}
  70.   var
  71.     BytesRead : Word;
  72.   begin
  73.     BlockRead(F, Buffer, Size, BytesRead);
  74.     BlkRead := (IoResult = 0) and (BytesRead = Size);
  75.   end;
  76.  
  77.   function BlkWrite(var F : file; var Buffer; Size : Word) : Boolean;
  78.     {-Convenient shell around BlockWrite}
  79.   var
  80.     BytesWritten : Word;
  81.   begin
  82.     BlockWrite(F, Buffer, Size, BytesWritten);
  83.     BlkWrite := (IoResult = 0) and (BytesWritten = Size);
  84.   end;
  85.  
  86.   procedure PackExe(ExeName, OutName : string);
  87.     {-Squeeze an EXE file by packing fixups into segment groups}
  88.   const
  89.     MaxRWbufSize = $8000;    {Max size of read/write buffer for EXE copying}
  90.     FlagWord = $FFFF;        {Flag segment changes in packed relocation table}
  91.     OrigIPofs = 3;           {Position of first patch word in NewLoader}
  92.     ShowRLEeffect = False;   {True to show value of run length encoding}
  93.     Threshold = 4;           {Bytes of overhead per RLE block}
  94.     MaxReloc = $3FFC;        {Maximum allowable relocation items}
  95.  
  96.     NewLoaderSize = 82;
  97.     NewLoader : array[1..NewLoaderSize] of Byte =
  98.     {This is a dump of the COM file generated by assembling NEWLOAD.ASM}
  99.     (
  100.      $EB, $08, $00, $00, $00, $00, $00, $00, $00, $00, $2E, $8C, $1E, $06, $00, $2E,
  101.      $8C, $06, $08, $00, $8C, $C3, $83, $C3, $10, $8C, $C8, $8E, $D8, $BE, $52, $00,
  102.      $FC, $AD, $3D, $FF, $FF, $75, $0B, $AD, $3D, $FF, $FF, $74, $0C, $03, $C3, $8E,
  103.      $C0, $AD, $8B, $F8, $26, $01, $1D, $EB, $E8, $2E, $8E, $06, $08, $00, $2E, $8E,
  104.      $1E, $06, $00, $8B, $C3, $2E, $03, $06, $04, $00, $50, $2E, $A1, $02, $00, $50,
  105.      $CB, $90
  106.      );
  107.  
  108.   type
  109.     ExeHeaderRec =           {Information describing EXE file}
  110.     record
  111.       Signature : Word;      {EXE file signature}
  112.       LengthRem : Word;      {Number of bytes in last page of EXE image}
  113.       LengthPages : Word;    {Number of 512 byte pages in EXE image}
  114.       NumReloc : Word;       {Number of relocation items}
  115.       HeaderSize : Word;     {Number of paragraphs in EXE header}
  116.       MinHeap, MaxHeap : Word; {Paragraphs to keep beyond end of image}
  117.       StackSeg, StackPtr : Word; {Initial SS:SP, StackSeg relative to image base}
  118.       CheckSum : Word;       {EXE file check sum, not used}
  119.       IpInit, CodeSeg : Word; {Initial CS:IP, CodeSeg relative to image base}
  120.       RelocOfs : Word;       {Bytes into EXE for first relocation item}
  121.       OverlayNum : Word;     {Overlay number, not used here}
  122.     end;
  123.     RelocRec =
  124.     record
  125.       Offset : Word;
  126.       Segment : Word;
  127.     end;
  128.     RelocArray = array[1..MaxReloc] of RelocRec;
  129.     PackedTable = array[1..$7FF0] of Word;
  130.     ReadWriteBuffer = array[1..MaxRWbufSize] of Byte;
  131.  
  132.   var
  133.     ExeF, OutF : file;
  134.     BytesRead, BytesWritten, RWbufSize,
  135.     I, TableSize, TablePos, LastSeg,
  136.     BlockSize, OldNumReloc, OldHeaderSize : Word;
  137.     OldExeSize, ExeSize, RLEbytes : LongInt;
  138.     LastByte : Byte;
  139.     ExeHeader : ExeHeaderRec;
  140.     RA : ^RelocArray;        {Old relocation table from input file}
  141.     PT : ^PackedTable;       {New relocation table after packing}
  142.     RWbuf : ^ReadWriteBuffer; {Read/write buffer for file copy}
  143.  
  144.     procedure SetTable(var TA : PackedTable; var TablePos : Word; Value : Word);
  145.       {-Put a value into packed table and increment the index}
  146.     begin
  147.       TA[TablePos] := Value;
  148.       Inc(TablePos);
  149.     end;
  150.  
  151.   begin
  152.  
  153.     {Make sure we don't overwrite the input}
  154.     if StUpcase(ExeName) = StUpcase(OutName) then
  155.       Error('Input and output files must differ');
  156.  
  157.     {Open the existing EXE file}
  158.     Assign(ExeF, ExeName);
  159.     Reset(ExeF, 1);
  160.     if IoResult <> 0 then
  161.       Error(ExeName+' not found');
  162.  
  163.     {Read the existing EXE header}
  164.     if not BlkRead(ExeF, ExeHeader, SizeOf(ExeHeaderRec)) then
  165.       Error('Error reading EXE file');
  166.  
  167.     with ExeHeader do begin
  168.  
  169.       {Assure it's a real EXE file}
  170.       if Signature <> $5A4D then
  171.         Error('File is not in EXE format');
  172.  
  173.       {Check the number of relocation items}
  174.       if NumReloc = 0 then
  175.         Error('No packing can be done. No output written');
  176.       if NumReloc > MaxReloc then
  177.         Error('Number of relocation items exceeds capacity of PACK');
  178.       if NumReloc shl 2 > MaxAvail then
  179.         Error('Insufficient memory');
  180.  
  181.       {Read the relocation items into memory}
  182.       GetMem(RA, NumReloc shl 2);
  183.       Seek(ExeF, RelocOfs);
  184.       if not BlkRead(ExeF, RA^, NumReloc shl 2) then
  185.         Error('Error reading EXE file');
  186.  
  187.       {Determine size of packed relocation table in bytes}
  188.       LastSeg := $FFFF;
  189.       TableSize := 0;
  190.       for I := 1 to NumReloc do
  191.         with RA^[I] do begin
  192.           if Segment <> LastSeg then begin
  193.             LastSeg := Segment;
  194.             {Table will hold FFFF as a flag, followed by new segment}
  195.             Inc(TableSize, 4);
  196.           end;
  197.           {Space for the offset in this record}
  198.           Inc(TableSize, 2);
  199.         end;
  200.       {Termination record}
  201.       Inc(TableSize, 4);
  202.  
  203.       {Build the packed relocation table in memory}
  204.       if TableSize > MaxAvail then
  205.         Error('Insufficient memory');
  206.  
  207.       GetMem(PT, TableSize);
  208.       LastSeg := $FFFF;
  209.       TablePos := 1;
  210.       for I := 1 to NumReloc do
  211.         with RA^[I] do begin
  212.           if Segment <> LastSeg then begin
  213.             LastSeg := Segment;
  214.             {Flag that the segment is changing}
  215.             SetTable(PT^, TablePos, FlagWord);
  216.             {Write the new segment}
  217.             SetTable(PT^, TablePos, Segment);
  218.           end;
  219.           {Write the offset in the segment}
  220.           SetTable(PT^, TablePos, Offset);
  221.         end;
  222.       {Write a termination record}
  223.       for I := 1 to 2 do
  224.         SetTable(PT^, TablePos, FlagWord);
  225.  
  226.       {Deallocate space for the old relocation array}
  227.       FreeMem(RA, NumReloc shl 2);
  228.  
  229.       {Allocate space for the read/write buffer}
  230.       if MaxAvail > MaxRWbufSize then
  231.         RWbufSize := MaxRWbufSize
  232.       else
  233.         RWbufSize := MaxAvail;
  234.       GetMem(RWbuf, RWbufSize);
  235.  
  236.       {Save some items we'll need later}
  237.       OldNumReloc := NumReloc; {items}
  238.       OldHeaderSize := HeaderSize; {paragraphs}
  239.       if LengthRem = 0 then
  240.         OldExeSize := LongInt(LengthPages) shl 9
  241.       else
  242.         OldExeSize := (LongInt(Pred(LengthPages)) shl 9)+LongInt(LengthRem);
  243.  
  244.       {Change the header to accomodate the packing}
  245.       {No fixups remain after packing}
  246.       NumReloc := 0;
  247.       {Headersize shrinks to size of header record, rounded to para boundary}
  248.       HeaderSize := (SizeOf(ExeHeaderRec)+15) shr 4; {paragraphs}
  249.       {Patch initial CS:IP into the new loader}
  250.       Move(IpInit, NewLoader[OrigIPofs], 4);
  251.       {Set up so our loader executes first}
  252.       IpInit := 0;
  253.       CodeSeg := Succ(OldExeSize shr 4)-OldHeaderSize; {paragraphs}
  254.  
  255.       {Compute new exesize}
  256.       ExeSize := (LongInt(HeaderSize)+LongInt(CodeSeg)) shl 4
  257.       +LongInt(NewLoaderSize)+LongInt(TableSize); {bytes}
  258.       if ExeSize >= OldExeSize then
  259.         Error('Packed size exceeds original. No output written');
  260.  
  261.       if (ExeSize and 511) = 0 then begin
  262.         {An exact number of pages}
  263.         LengthPages := ExeSize shr 9;
  264.         LengthRem := 0;
  265.       end else begin
  266.         LengthPages := Succ(ExeSize shr 9);
  267.         LengthRem := ExeSize-LongInt(Pred(LongInt(LengthPages)) shl 9);
  268.       end;
  269.  
  270.       {Create the new EXE file}
  271.       Assign(OutF, OutName);
  272.       Rewrite(OutF, 1);
  273.       if IoResult <> 0 then
  274.         Error('Could not create '+OutName);
  275.  
  276.       {Write the new header}
  277.       if not BlkWrite(OutF, ExeHeader, (HeaderSize shl 4)) then
  278.         Error('Error writing EXE file');
  279.  
  280.       {Transfer the code from old to new program}
  281.       Seek(ExeF, OldHeaderSize shl 4);
  282.  
  283.       {Initialize parameters for run length encoding}
  284.       LastByte := 0;
  285.       BlockSize := 0;
  286.       RLEbytes := 00;
  287.  
  288.       repeat
  289.         BlockRead(ExeF, RWbuf^, RWbufSize, BytesRead);
  290.         if IoResult <> 0 then
  291.           Error('Error reading EXE file');
  292.         if BytesRead <> 0 then begin
  293.           if not BlkWrite(OutF, RWbuf^, BytesRead) then
  294.             Error('Error writing EXE file');
  295.  
  296.           if ShowRLEeffect then
  297.             {Check to see how much run length packing would save}
  298.             for I := 1 to BytesRead do
  299.               if RWbuf^[I] = LastByte then
  300.                 Inc(BlockSize)
  301.               else begin
  302.                 LastByte := RWbuf^[I];
  303.                 if BlockSize > Threshold then
  304.                   Inc(RLEbytes, BlockSize-Threshold);
  305.                 BlockSize := 0;
  306.               end;
  307.         end;
  308.       until BytesRead = 0;
  309.  
  310.       if ShowRLEeffect then
  311.         if BlockSize > Threshold then
  312.           Inc(RLEbytes, BlockSize-Threshold);
  313.  
  314.       {Write the loader to the new program}
  315.       Seek(OutF, (LongInt(HeaderSize)+LongInt(CodeSeg)) shl 4);
  316.       if not BlkWrite(OutF, NewLoader, NewLoaderSize) then
  317.         Error('Error writing EXE file');
  318.  
  319.       {Write the packed loader table to the program}
  320.       if not BlkWrite(OutF, PT^, TableSize) then
  321.         Error('Error writing EXE file');
  322.  
  323.       if ShowRLEeffect then
  324.         WriteLn('Run length packing would save ', RLEbytes, ' bytes');
  325.  
  326.     end;
  327.  
  328.     {Release heap space we allocated}
  329.     FreeMem(PT, TableSize);
  330.     FreeMem(RWbuf, RWbufSize);
  331.  
  332.     {Close up the files}
  333.     Close(ExeF);
  334.     Close(OutF);
  335.   end;
  336.  
  337. begin
  338.   Writeln('PACK 1.0, by TurboPower Software');
  339.   if ParamCount < 2 then
  340.     Error('Usage: PACK OldExeName NewExeName');
  341.   {Modify the EXE file}
  342.   PackExe(ForceExtension(ParamStr(1), 'EXE'), ForceExtension(ParamStr(2), 'EXE'));
  343. end.
  344.